#  File src/library/methods/R/Methods.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2019 The R Core Team
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  A copy of the GNU General Public License is available at
#  https://www.R-project.org/Licenses/

## copy here to avoid importing from stats and hence loading stats
## namespace when methods if loaded
setNames <- stats::setNames


setGeneric <-
  ## Define `name' to be a generic  function, for which methods will be defined.
  ##
  ## If there is already a non-generic function of this name, it will be used
  ## to define the generic unless `def' is supplied, and the current
  ## function will become the default method for the generic.
  ##
  ## If `def' is supplied, this defines the generic function.  The
  ## default method for a new generic will usually be an existing
  ## non-generic.  See the .Rd page
  ##
    function(name, def = NULL, group = list(), valueClass = character(),
             where = topenv(parent.frame()),
             package = NULL, signature = NULL,
             useAsDefault = NULL, genericFunction = NULL,
             simpleInheritanceOnly = NULL)
{
    if(is.character(.isSingleName(name)))
        stop(gettextf("invalid argument 'name': %s",
                      .isSingleName(name)), domain = NA)
    if(exists(name, "package:base") && inBasicFuns(name)) {

        name <- switch(name, "as.double" = "as.numeric", name)
        fdef <- getGeneric(name) # will fail if this can't have methods
        compatibleSignature <- nargs() == 2L && !missing(signature) &&
            identical(signature, fdef@signature)
        if(nargs() <= 1 || compatibleSignature) {
            ## generics for primitives are global, so can & must always be cached
            .cacheGeneric(name, fdef)
            return(name)
        }
        ## you can only conflict with a primitive if you supply
        ## useAsDefault to signal you really mean a different function
        if(!is.function(useAsDefault) && !isFALSE(useAsDefault)) {
            msg <- gettextf("%s dispatches internally;  methods can be defined, but the generic function is implicit, and cannot be changed.", sQuote(name))
            stop(msg, domain = NA)
        }
    }
    simpleCall <- { nargs() < 2 ||
		    all(missing(def), missing(group), missing(valueClass),
			missing(package), missing(signature), missing(useAsDefault),
			missing(genericFunction), missing(simpleInheritanceOnly)) }
    stdGenericBody <- substitute(standardGeneric(NAME), list(NAME = name))
    ## get the current function which may already be a generic
    fdef <-
	if(is.null(package))
	    getFunction(name, mustFind = FALSE, where = where)
	else {
	    ev <- .NamespaceOrPackage(package)
	    if(simpleCall)
		implicitGeneric(name, ev) # generic or NULL
	    else
		getFunction(name, mustFind = FALSE, where = ev)
	}
    if(simpleCall) {
        if(is(fdef, "genericFunction"))
          return(.GenericAssign(name, fdef, where))
    }
    if(is.null(fdef)) {
        if(isNamespace(where))
            fdef <- .getFromStandardPackages(name)
        else
            fdef <- getFunction(name, mustFind = FALSE)
    }
    if(is.null(fdef) && is.function(useAsDefault))
        fdef <- useAsDefault
    ## Use the previous function definition to get the default
    ## and to set the package if not supplied.
    doUncache <- FALSE
    if(is.object(fdef) && is(fdef, "genericFunction")) {
        doUncache <- TRUE
        oldDef <- fdef
        prevDefault <- finalDefaultMethod(fdef@default)
        if(is.null(package))
            package <- fdef@package
    }
    else if(is.function(fdef)) {
        prevDefault <- fdef
        if(is.primitive(fdef)) package <- "base"
        if(is.null(package))
            package <- getPackageName(environment(fdef))
    }
    else
        prevDefault <- NULL

    if(is.primitive(fdef)) ## get the pre-defined version
        fdef <- getGeneric(name, where = where)
    else if(is.function(fdef))
        body(fdef, envir = as.environment(where)) <- stdGenericBody
    if(!is.null(def)) {
        if(is.primitive(def) || !is.function(def))
            stop(gettextf("if the 'def' argument is supplied, it must be a function that calls standardGeneric(\"%s\") or is the default",
                          name), domain = NA)
        nonstandardCase <- .NonstandardGenericTest(body(def), name, stdGenericBody)
        if(is.na(nonstandardCase)) {
            if(is.null(useAsDefault)) {# take this as the default
                useAsDefault <- def
            }
            body(def, envir = as.environment(where)) <- stdGenericBody
            nonstandardCase <- FALSE
        }
        fdef <- def
        if(is.null(genericFunction) && nonstandardCase)
            genericFunction <- new("nonstandardGenericFunction") # force this class for fdef
    }
    thisPackage <- getPackageName(where)
    if(is.null(package) || !nzchar(package))
        ## either no previous def'n or failed to find its package name
        package <- thisPackage
    if(is.null(fdef))
        stop(gettextf("must supply a function skeleton for %s, explicitly or via an existing function", sQuote(name)), domain = NA)
    ensureGeneric.fdef <- function(sig = signature) {
        if(!(is.object(fdef) && is(fdef, "genericFunction"))) {
            fdeflt <-
                if(is.function(useAsDefault)) useAsDefault
                else if(isFALSE(useAsDefault)) NULL
                else if(is.function(prevDefault) &&
                        !identical(formalArgs(prevDefault), formalArgs(fdef)) &&
                        !is.primitive(prevDefault))
                    NULL
                else prevDefault
            if(is.function(fdeflt))
                fdeflt <- .derivedDefaultMethod(fdeflt)
            fdef <<-
                makeGeneric(name, fdef, fdeflt, group=group, valueClass=valueClass,
                            package = package, signature = sig,
                            genericFunction = genericFunction,
                            simpleInheritanceOnly = simpleInheritanceOnly)
        }
    }
    if(identical(package, thisPackage)) {
        ensureGeneric.fdef()
    } else {
        ## setting a generic for a function in another package.
        ## In this case, the generic definition must agree with the implicit
        ## generic for the given function and package
        implicit <- implicitGeneric(name, .NamespaceOrPackage(package))
        if(is.null(implicit)) { # New function, go ahead
            ensureGeneric.fdef()
        }
        else {
	    ## possibly take the signature from the *implicit* generic:
	    ensureGeneric.fdef(if(is.null(signature) && is.null(def))
			       implicit@signature else signature)
	    cmp <- .identicalGeneric(fdef, implicit,
				     allow.extra.dots =
				     !nzchar(Sys.getenv("R_SETGENERIC_PICKY_DOTS")))
            if(isTRUE(cmp)) {
                fdef <- implicit
            }  # go ahead silently
            else if(is.function(implicit)) {
                thisPName <- if(identical(thisPackage, ".GlobalEnv"))
                    "the global environment" else paste("package", sQuote(thisPackage))
                ## choose the implicit unless an explicit def was given
                if(is.null(def) && is.null(signature)) {
                    message(gettextf(
                       "Creating a generic function for %s from %s in %s\n    (from the saved implicit definition)",
                                     sQuote(name), sQuote(package),
                                     thisPName), domain = NA)
                    fdef <- implicit
                }
                else {
                    message(gettextf(
                         "Creating a new generic function for %s in %s",
                                     sQuote(name), thisPName),
                         domain = NA)
                    fdef@package <- packageSlot(fdef@generic) <- packageSlot(environment(fdef)$.Generic) <- thisPackage
                }
            }
            else { # generic prohibited
                warning(gettextf(
			"no generic version of %s on package %s is allowed;\n   a new generic will be assigned for %s",
                                 sQuote(name), sQuote(package),
                                 thisPName),
                        domain = NA)
                fdef@package <- packageSlot(fdef@generic) <- packageSlot(environment(fdef)$.Generic) <- thisPackage
            }
        }
    }
    if(identical(fdef@signature, "..."))
	fdef <- .dotsGeneric(fdef)
    if(doUncache)
	.uncacheGeneric(name, oldDef)
    groups <- fdef@group
    for(group in groups) { # add as member of group generic(s) if not there
        gdef <- getGeneric(group)
        if(is(gdef, "groupGenericFunction") &&
           is.na(match(fdef@generic, as.character(gdef@groupMembers)))) {
            gwhere <- .genEnv(group, where)
            gdef@groupMembers <- c(gdef@groupMembers, list(fdef@generic))
            assign(group, gdef, gwhere)
        }
    }
    .GenericAssign(name, fdef, where)
}

.GenericAssign <- function(name, fdef, where) {
    assign(name, fdef, where)
    .cacheGeneric(name, fdef)
    methods <- fdef@default # empty or containing the default
    assignMethodsMetaData(name, methods, fdef, where)
    .assignMethodsTableMetaData(name, fdef, where)
    name
}

## Mimic the search for a function in the standard search() list for packages
## with namespace, to be consistent with the evaluator's search for objects
### Deprecate? Seems like we should search the imports, not the search path
.standardPackageNamespaces <- new.env()
.standardPackages <- c("stats", "graphics", "grDevices", "utils", "datasets", "methods")
.getFromStandardPackages <- function(name) {
    namespaces <- as.list(.standardPackageNamespaces, all.names=TRUE)
    if(length(namespaces) == 0L) { # initialize the table of namespaces
        namespaces <- lapply(.standardPackages, function(pkg) {
            tryCatch(loadNamespace(pkg),
                     error = function(e) new.env())
        })
        names(namespaces) <- .standardPackages
        list2env(namespaces, .standardPackageNamespaces)
    } else {
        for(ns in namespaces) {
            obj <- ns[[name]]
            if(is.function(obj))
              return(obj)
        }
    }
    return(NULL)
}

##
## make a generic function object corresponding to the given function name.
##

isGeneric <-
  ## Is there a function named `f', and if so, is it a generic?
  ##
  ## If the `fdef' argument is supplied, take this as the definition of the
  ## generic, and test whether it is really a generic, with `f' as the name of
  ## the generic.  (This argument is not available in S-Plus.)
  function(f, where = topenv(parent.frame()), fdef = NULL, getName = FALSE)
{
    if(is.null(fdef) && missing(where)) {
         fdef <- .getGenericFromCache(f, where)
        ## a successful search will usually end here w/o other tests
         if(!is.null(fdef))
           return(if(getName) fdef@generic else TRUE)
     }
    if(is.null(fdef))
        fdef <- getFunction(f, where=where, mustFind = FALSE)
    if(is.null(fdef))
      return(FALSE)
    ## check primitives. These are never found as explicit generic functions.
    if(isBaseFun(fdef)) {
        if(is.character(f) && f %in% "as.double") f <- "as.numeric"
        ## the definition of isGeneric() for a base function is that methods are defined
        ## (other than the default primitive)
        gen <- genericForBasic(f, mustFind = FALSE)
        return(is.function(gen) && length(names(.getMethodsTable(gen))) > 1L)
    }
    if(!is(fdef, "genericFunction"))
        return(FALSE)
    gen <- fdef@generic # the name with package attribute
    if(missing(f) || .identC(gen, f)) {
	if(getName)
	    gen
	else
	    TRUE
    }
    else {
        warning(gettextf("function %s appears to be a generic function, but with generic name %s",
                         sQuote(f), sQuote(gen)),
                domain = NA)
        FALSE
    }
}

removeGeneric <-
  ## Remove the generic function of this name, specifically the first version
  ## encountered from environment where
  ##
    function(f, where = topenv(parent.frame()))
{
    fdef <- NULL
    allEv <- findFunction(f, where = where)
    for(maybeEv in allEv) {
        fdef <- get(f, maybeEv)
        if(is(fdef, "genericFunction"))
            break
    }
    found <- is(fdef, "genericFunction")
    if(found) {
         .removeMethodsMetaTable(fdef, where)
         oldMetaName <- methodsPackageMetaName("M",fdef@generic, fdef@package)
         if(exists(oldMetaName, where, inherits = FALSE))
           rm(list = oldMetaName, pos = where)
        .uncacheGeneric(f, fdef)
        rm(list = fdef@generic, pos = where)
    }
    else {
        if(!is.character(f))
            f <- deparse(f)
        warning(gettextf("generic function %s not found for removal",
                         sQuote(f)),
                domain = NA)
    }
    return(found)
}

getMethods <-
    ## The list of methods for the specified generic.  If the function is not
    ## a generic function, returns NULL.
    ## The `f' argument can be either the character string name of the generic
    ## or the object itself.
    ##
    ## The `where' argument optionally says where to look for the function, if
    ## `f' is given as the name.
    ## This function returns a MethodsList object, no longer used for method dispatch
    ## A better structure for most purposes is the linear methods list returned by findMethods()
    ## There are no plans currently to make getMethods defunct, but it will be less
    ## efficient than findMethods()  both for creating the object and using it.

  ##  The function getMethods continues to
  ## return a methods list object, but now this is the metadata from where,
  ## or is converted from the internal table if where is missing
  ## or Mlists are dummies.

    function(f, where = topenv(parent.frame()), table = FALSE)
{
    if(!table)
      .MlistDefunct("getMethods", "findMethods")
    nowhere <- missing(where)
    fdef <- getGeneric(f, where = where)
    f <- fdef@generic
    if(!is.null(fdef)) {
        if(table)
          return(getMethodsForDispatch(fdef, TRUE))
    } ## else NULL
}

getMethodsForDispatch <- function(fdef, inherited = FALSE)
{
    .getMethodsTable(fdef, environment(fdef), inherited = inherited)
}

## Some functions used in MethodsListSelect, that must be safe against recursive
## method selection.

.setIfBase <- function(f, fdef, mlist) {
    if(is.null(f))
        FALSE
    else {
        found <- base::exists(f, "package:base")
	if(found) {
	    ## force (default) computation of mlist in MethodsListSelect
	    base::assign(".Methods", envir = base::environment(fdef),
			 base::get(f, "package:base"))
	}
        found
    }
}

## Must NOT use the standard version to prevent recursion  {still true ?}
.getMethodsForDispatch <- function(fdef) {
    ev <- base::environment(fdef)
    if(base::exists(".Methods", envir = ev))
        base::get(".Methods", envir = ev)
    ## else NULL
}

.setMethodsForDispatch <- function(f, fdef, mlist) {
    ev <- environment(fdef)
    if(!is(fdef, "genericFunction") ||
       !exists(".Methods", envir = ev, inherits = FALSE))
        stop(sprintf("internal error: did not get a valid generic function object for function %s",
                      sQuote(f)),
             domain = NA)
    assign(".Methods", envir = ev, mlist)
}

cacheMethod <-
  ## cache the given definition in the method metadata for f
  ## Support function:  DON'T USE DIRECTLY (does no checking)
  function(f, sig, def, args = names(sig), fdef, inherited = FALSE) {
      ev <- environment(fdef)

      .cacheMethodInTable(fdef, sig, def,
			  .getMethodsTable(fdef, ev, inherited = inherited))
      ## if this is not an inherited method, update the inherited table as well
      ## TODO:	in this case, should uncache inherited methods, though the callin
      ##  function will normally have done this.
      if(!inherited)
	  .cacheMethodInTable(fdef, sig, def,
			      .getMethodsTable(fdef, ev, inherited = TRUE))
  }

.removeCachedMethod <- function(f, sig, fdef = getGeneric(f))
    cacheMethod(f, sig, NULL, names(sig), fdef)


setMethod <-
    ## Define a method for the specified combination of generic function and signature.
    ## The method is stored in the methods meta-data of the specified database.
    ##
    ## Note that assigning methods anywhere but the global environment (`where==1') will
    ## not have a permanent effect beyond the current R session.
    function(f, signature = character(), definition,
	     where = topenv(parent.frame()), valueClass = NULL,
	     sealed = FALSE)
{
    ## Methods are stored in metadata in database where.  A generic function will be
    ## assigned if there is no current generic, and the function is NOT a primitive.
    ## Primitives are dispatched from the main C code, and an explicit generic NEVER
    ## is assigned for them.
    if(is.function(f) && is(f, "genericFunction")) {
        ## (two-part test to deal with bootstrapping of methods package)
        fdef <- f
        f <- fdef@generic
        gwhere <- .genEnv(f)
    }
    else if(is.function(f)) {
        if(is.primitive(f)) {
            f <- .primname(f)
            fdef <- genericForBasic(f)
            gwhere <- .genEnv(f)
        }
        else
            stop("a function for argument 'f' must be a generic function")
    }
    ## slight subtlety:  calling getGeneric vs calling isGeneric
    ## For primitive functions, getGeneric returns the (hidden) generic function,
    ## even if no methods have been defined.  An explicit generic MUST NOT be
    ## for these functions, dispatch is done inside the evaluator.
    else {
        where <- as.environment(where)
        gwhere <- .genEnv(f, where)
        f <- switch(f, "as.double" = "as.numeric", f)
        fdef <- getGeneric(f, where = if(identical(gwhere, baseenv())) where else gwhere)
    }
    if(.lockedForMethods(fdef, where))
        stop(gettextf("the environment %s is locked; cannot assign methods for function %s",
                      sQuote(getPackageName(where)),
                      sQuote(f)),
             domain = NA)
    hasMethods <- !is.null(fdef)
    deflt <- getFunction(f, generic = FALSE, mustFind = FALSE, where = where)
    ## where to insert the methods in generic
    if(identical(gwhere, baseenv())) {
        allWhere <- findFunction(f, where = where)
        generics <- logical(length(allWhere))
        if(length(allWhere)) { # put methods into existing generic
            for(i in seq_along(allWhere)) {
                fi <- get(f, allWhere[[i]])
                geni <- is(fi, "genericFunction")
                generics[[i]] <- geni
                if(!geni && is.null(deflt))
                    deflt <- fi
            }
        }
        if(any(generics)) {
            ## try to add method to the existing generic, but if the corresponding
            ## environment is sealed, must create a new generic in where
            gwhere <- as.environment(allWhere[generics][[1L]])
            if(.lockedForMethods(fdef, gwhere)) {
                if(identical(as.environment(where), gwhere))
                    stop(gettextf("the 'where' environment (%s) is a locked namespace; cannot assign methods there",
                                  getPackageName(where)), domain = NA)
                msg <-
                    gettextf("Copying the generic function %s to environment %s, because the previous version was in a sealed namespace (%s)",
                             sQuote(f),
                             sQuote(getPackageName(where)),
                             sQuote(getPackageName(gwhere)))
                message(strwrap(msg), domain = NA)
                assign(f, fdef, where)
                gwhere <- where
            }
        }
    }
    if(!hasMethods)
        fdef <- deflt
    if(is.null(fdef))
        stop(gettextf("no existing definition for function %s",
                      sQuote(f)),
             domain = NA)
    if(!hasMethods) {
        ## create using the visible non-generic as a pattern and default method
        setGeneric(f, where = where)
        doMessage <- !isS3Generic(fdef)
        fdef <- getGeneric(f, where = where)
        if(doMessage) {
            thisPackage <- getPackageName(where)
            thisPName <- if(identical(thisPackage, ".GlobalEnv"))
                             "the global environment" else paste("package", sQuote(thisPackage))
            if(identical(as.character(fdef@package), thisPackage))
                message(gettextf("Creating a generic function from function %s in %s",
                                 sQuote(f), thisPName), domain = NA)
            else
                message(gettextf("Creating a generic function for %s from package %s in %s",
                                 sQuote(f), sQuote(fdef@package), thisPName),
                        domain = NA)
        }
    }
    else if(identical(gwhere, NA)) {
        ## better be a primitive since getGeneric returned a generic, but none was found
	if(is.null(.BasicFunsList[[f]]))
            stop(sprintf("apparent internal error: a generic function was found for \"%s\", but no corresponding object was found searching from \"%s\"",
                          f, getPackageName(where)), domain = NA)
        if(!isGeneric(f))
            setGeneric(f) # turn on this generic and cache it.
    }
    if(isSealedMethod(f, signature, fdef, where=where))
        stop(gettextf("the method for function %s and signature %s is sealed and cannot be re-defined",
                      sQuote(f),
                      .signatureString(fdef, signature)),
             domain = NA)
    signature <- matchSignature(signature, fdef, where)
    createMethod <- FALSE # TRUE for "closure" only
    switch(typeof(definition),
	   "closure" = {
	       fnames <- formalArgs(fdef)
	       mnames <- formalArgs(definition)
	       if(!identical(mnames, fnames)) {
		   ## fix up arg name for single-argument generics
		   ## useful for e.g. '!'
		   if(length(fnames) == length(mnames) && length(mnames) == 1L) {
		       warning(gettextf("For function %s, signature %s: argument in method definition changed from (%s) to (%s)",
					sQuote(f),
                                        sQuote(signature),
                                        mnames,
                                        fnames),
                               domain = NA, call. = FALSE)
		       formals(definition) <- formals(fdef)
		       ll <- list(as.name(formalArgs(fdef))); names(ll) <- mnames
		       body(definition) <- substituteDirect(body(definition), ll)
		       mnames <- fnames
		   }
		   else {
		       ## omitted arguments (classes) in method => "missing"
		       fullSig <- conformMethod(signature, mnames, fnames, f, fdef, definition)
		       if(!identical(fullSig, signature)) {
			   formals(definition, envir = environment(definition)) <- formals(fdef)
			   signature <- fullSig
		       }
		       ## extra arguments (classes) in method => use "..." to rematch
		       definition <- rematchDefinition(definition, fdef, mnames, fnames, signature)
		   }
	       }
	       definition <- matchDefaults(definition, fdef) # use generic's defaults if none in method
               createMethod <- TRUE
	   },
	   "builtin" = , "special" = {
	       ## the only primitive methods allowed are those equivalent
	       ## to the default, for generics that were primitives before
	       ## and will be dispatched by C code.
	       if(!identical(definition, deflt))
		   stop("primitive functions cannot be methods; they must be enclosed in a regular function")
	   },
	   "NULL" = {

	   },
           stop(gettextf("invalid method definition: expected a function, got an object of class %s",
			 dQuote(class(definition))), domain = NA)
	   )
    fenv <- environment(fdef)
    ## check length against active sig. length, reset if necessary in .addToMetaTable
    nSig <- .getGenericSigLength(fdef, fenv, TRUE)
    signature <- .matchSigLength(signature, fdef, fenv, TRUE)
    margs <- (fdef@signature)[seq_along(signature)]
    if(createMethod) {
        definition <- asMethodDefinition(definition, signature, sealed, fdef)
        definition@generic <- fdef@generic
    }
    is.not.base <- !identical(where, baseenv())
    whereMethods <-
	## do.mlist <- is.not.base && (!.noMlists() || all(signature == "ANY"))
	if(is.not.base && !.noMlists()) # do.mlist
	    insertMethod(getMethodsMetaData(f, where),
			 signature, margs, definition) ## else NULL
    mtable <- getMethodsForDispatch(fdef)
    if(cacheOnAssign(where)) { # will be FALSE for sourceEnvironment's
        ## cache in both direct and inherited tables
        .cacheMethodInTable(fdef, signature, definition, mtable) #direct
        .cacheMethodInTable(fdef, signature, definition) # inherited, by default
        if(is.not.base)
            .addToMetaTable(fdef, signature, definition, where, nSig)
        resetGeneric(f, fdef, mtable, gwhere, deflt) # Note: gwhere not used by resetGeneric
    }
    ## assigns the methodslist object
    ## and deals with flags for primitives & for updating group members
    assignMethodsMetaData(f, whereMethods, fdef, where)
    invisible(f)
}

removeMethod <- function(f, signature = character(), where = topenv(parent.frame())) {
    if(is.function(f)) {
      if(is(f, "genericFunction"))
         { fdef <- f; f <- f@generic}
      else if(is.primitive(f))
        { f <- .primname(f); fdef <- genericForBasic(f, mustFind=FALSE)}
      else
        stop("function supplied as argument 'f' must be a generic")
    }
    else
      fdef <- getGeneric(f, where = where)
    if(is.null(fdef)) {
        warning(gettextf("no generic function %s found", sQuote(f)),
                domain = NA)
        return(FALSE)
    }
    if(is.null(getMethod(fdef, signature, optional=TRUE))) {
        warning(gettextf("no method found for function %s and signature %s",
                         sQuote(fdef@generic),
                         paste(.dQ(signature), collapse =", ")),
                domain = NA)
        return(FALSE)
    }
    setMethod(f, signature, NULL, where = where)
    TRUE
}

## an extension to removeMethod that resets inherited methods as well
.undefineMethod <- function(f, signature = character(), where = topenv(parent.frame())) {
    fdef <- getGeneric(f, where = where)
    if(is.null(fdef)) {
        warning(gettextf("no generic function %s found",
                         sQuote(f)),
                domain = NA)
        return(FALSE)
    }
    if(!is.null(getMethod(fdef, signature, optional=TRUE)))
      setMethod(f, signature, NULL, where = where)
  }

findMethod <- function(f, signature, where = topenv(parent.frame())) {
    if(is(f, "genericFunction")) {
        fdef <- f
        f <- fdef@generic
    }
    else
	fdef <- getGeneric(f, where = where)
    if(is.null(fdef)) {
        warning(gettextf("no generic function %s found",
                         sQuote(f)),
                domain = NA)
        return(character())
    }
    fM <- .TableMetaName(fdef@generic, fdef@package)
    where <- .findAll(fM, where)
    found <- logical(length(where))
    for(i in seq_along(where)) {
        wherei <- where[[i]]
        table <- get(fM, wherei, inherits=FALSE)
        ## because we are using the table from the package, we must
        ## search for both the unexpanded & expanded signature, which
        ## .findMethodInTable does not do.
        mi <- .findMethodForFdef(signature, table, fdef)
        found[i] <- !is.null(mi)
    }
    value <- where[found]
    ## to conform to the API, try to return a numeric or character vector
    ## if possible
    what <- vapply(value, class, "", USE.NAMES=FALSE)
    if(identical(what, "numeric") || identical(what, "character"))
        unlist(value)
    else
        value
}

getMethod <-
  ## Return the function that is defined as the method for this generic function and signature
  ## (classes to be matched to the arguments of the generic function).
  function(f, signature = character(), where = topenv(parent.frame()), optional = FALSE,
           mlist, fdef )
{
    if(!missing(where)) {
        env <- .NamespaceOrEnvironment(where)
        if(is.null(env))
          stop(gettextf("no environment or package corresponding to argument where=%s",
               deparse(where)), domain = NA)
        where <- env
    }
    if(missing(fdef)) {
        if(missing(where))
          fdef <- getGeneric(f, FALSE)
        else {
            fdef <- getGeneric(f, FALSE, where = where)
            if(is.null(fdef))
              fdef <- getGeneric(f, FALSE)
        }
    }
    if(!is(fdef, "genericFunction")) {
	if(optional)
	    return(NULL)
	## else
	if(!is.character(f)) f <- deparse1(substitute(f))
	stop(gettextf("no generic function found for '%s'", f), domain = NA)
    }
    if(missing(mlist))
	mlist <-
	    if(missing(where))
		getMethodsForDispatch(fdef)
	    else
		.getMethodsTableMetaData(fdef, where, optional)
    if(is.environment(mlist)) {
	signature <- matchSignature(signature, fdef)
	value <- .findMethodInTable(signature, mlist, fdef)
	if(is.null(value) && !optional) {
	    if(!is.character(f)) f <- deparse1(substitute(f))
	    stop(gettextf("no method found for function '%s' and signature %s",
			  f, paste(signature, collapse = ", ")))
	}
        return(value)
    }
    else if(is.null(mlist)) return(mlist)

    ## the rest of the code will be executed only if a methods list object is supplied
    ## as an argument.  Should be deleted from 2.8.0 --> Error from 3.2.0
    stop("defunct methods list search", domain = NA)
}

dumpMethod <-
  ## Dump the method for this generic function and signature.
  ## The resulting source file will recreate the method.
  function(f, signature=character(), file = defaultDumpName(f, signature),
           where = topenv(parent.frame()),
           def = getMethod(f, signature, where=where, optional = TRUE))
{
    if(!is.function(def))
        def <- getMethod(f, character(), where=where, optional = TRUE)

    ## sink() handling as general as possible -- unbelievably unpretty coding:
    closeit <- TRUE ; isSTDOUT <- FALSE
    if (is.character(file)) {
        if(!(isSTDOUT <- file == "")) ## stdout() -- no sink() needed
            file <- file(file, "w")
    }
    else if (inherits(file, "connection")) {
	if (!isOpen(file)) open(file, "w") else closeit <- FALSE
    } else stop("'file' must be a character string or a connection")
    if(!isSTDOUT){ sink(file); on.exit({sink(); if(closeit) close(file)}) }

    cat("setMethod(\"", f, "\", ", deparse(signature), ",\n", sep="")
    dput(def@.Data)
    cat(")\n", sep="")
    if(!isSTDOUT) { on.exit(); sink(); if(closeit) close(file) }
    invisible(file)
}

dumpMethods <- function(f, file = "", signature = NULL, methods= findMethods(f, where = where),
                        where = topenv(parent.frame()) )
{
    ## The signature argument was used in recursive calls to dumpMethods()
    ## using the old MethodsList objects.  It is not meaningful with
    ## the current listOfMethods class
    if(length(signature) > 0)
        warning("argument 'signature' is not meaningful with the current implementation and is ignored \n(extract a subset of the methods list instead)")

    ## sink() handling as general as possible -- unbelievably unpretty coding:
    closeit <- TRUE ; isSTDOUT <- FALSE
    if (is.character(file)) {
        if(!(isSTDOUT <- file == "")) ## stdout() -- no sink() needed
            file <- file(file, "w")
    }
    else if (inherits(file, "connection")) {
	if (!isOpen(file)) open(file, "w") else closeit <- FALSE
    } else stop("'file' must be a character string or a connection")
    if(!isSTDOUT){ sink(file); on.exit({sink(); if(closeit) close(file)}) }
    sigs <- methods@signatures
    for(i in seq_along(methods))
        dumpMethod(f, sigs[[i]], file = "", def = methods[[i]])
}


selectMethod <-
    ## Returns the method (a function) that R would use to evaluate a call to
    ## generic 'f' with arguments corresponding to the specified signature.
    function(f, signature, optional = FALSE, useInherited = TRUE,
	     mlist = if(!is.null(fdef)) getMethodsForDispatch(fdef),
	     fdef = getGeneric(f, !optional), verbose = FALSE, doCache = FALSE)
{
    if(is.environment(mlist))  {# using methods tables
        fenv <- environment(fdef)
        nsig <- .getGenericSigLength(fdef, fenv, FALSE)
        if(verbose)
            cat("* mlist environment with", length(mlist),"potential methods\n")
        if(length(signature) < nsig)
            signature[(length(signature)+1):nsig] <- "ANY"
        if(identical(fdef@signature, "...")) {
            method <- .selectDotsMethod(signature, mlist,
                 if(useInherited) getMethodsForDispatch(fdef, inherited = TRUE))
            if(is.null(method) && !optional)
              stop(gettextf("no method for %s matches class %s",
                            sQuote("..."), dQuote(signature)),
                   domain = NA)
            return(method)
        }
        method <- .findMethodInTable(signature, mlist, fdef)
	if(is.null(method)) {
	    if(missing(useInherited))
		useInherited <- (is.na(match(signature, "ANY")) & # -> vector
				 if(identical(fdef, coerce))# careful !
				 c(TRUE,FALSE) else TRUE)
	    if(verbose) cat("  no direct match found to signature (",
			    paste(signature, collapse=", "),")\n", sep="")
	    methods <-
		if(any(useInherited)) {
		    allmethods <- .getMethodsTable(fdef, fenv, check=FALSE,
                                                   inherited=TRUE)
		    ## look in the supplied (usually standard) table
		    .findInheritedMethods(signature, fdef,
					  mtable = allmethods, table = mlist,
					  useInherited = useInherited,
                                          verbose = verbose, doCache = doCache)
		    ##MM: TODO? allow 'excluded' to be passed
		}
		## else list() : just look in the direct table

	    if(length(methods))
		return(methods[[1L]])
	    else if(optional)
		return(NULL)
	    else stop(gettextf("no method found for signature %s",
			       paste(signature, collapse=", ")))
	}
	else
	  return(method)
    }
    else if(is.null(mlist)) {
	if(optional)
	    return(mlist)
	else
	    stop(gettextf("%s has no methods defined",
                          sQuote(f)),
                 domain = NA)
    }
    else ## mlist not an environment nor NULL :
	stop("selectMethod(): mlist is not an environment or NULL :\n",
	     "** should no longer happen!", domain = NA)
}

hasMethod <-
  ## returns `TRUE' if `f' is the name of a generic function with an (explicit or inherited) method for
  ## this signature.
  function(f, signature = character(), where = .genEnv(f, topenv(parent.frame())))
{
    fdef <- getGeneric(f, where = where)
    if(is.null(fdef))
        FALSE
    else
        !is.null(selectMethod(f, signature, optional = TRUE, fdef = fdef))
}

existsMethod <-
  ## returns `TRUE' if `f' is the name of a generic function with an (explicit) method for
  ## this signature.
  function(f, signature = character(), where = topenv(parent.frame()))
{
        if(missing(where))
          method <- getMethod(f, signature,  optional = TRUE)
        else
          method <- getMethod(f, signature, where = where, optional = TRUE)
        !is.null(method)
}

signature <-
  ## A named list of classes to be matched to arguments of a generic function.
  ## It is recommended to supply signatures to `setMethod' via a call to `signature',
  ## to make clear which arguments are being used to select this method.
  ## It works, however, just to give a vector of character strings, which will
  ## be associated with the formal arguments of the function, in order.  The advantage
  ## of using `signature' is to provide a check on which arguments you meant, as well
  ## as clearer documentation in your method specification.  In addition, `signature'
  ## checks that each of the elements is a single character string.
  function(...)
{
    value <- list(...)
    names <- names(value)
    for(i in seq_along(value)) {
        sigi <- value[[i]]
        if(!is.character(sigi) || length(sigi) != 1L)
            stop(gettextf(
		"bad class specified for element %d (should be a single character string)",
		i), domain = NA)

    }
    setNames(as.character(value), names)
}

showMethods <-
    ## Show all the methods for the specified function.
    ##
    ## If `where' is supplied, the definition from that database will
    ## be used; otherwise, the current definition is used (which will
    ## include inherited methods that have arisen so far in the
    ## session).
    ##
    ## The output style is different from S-Plus in that it does not
    ## show the database from which the definition comes, but can
    ## optionally include the method definitions, if `includeDefs == TRUE'.
    ##
    function(f = character(), where = topenv(parent.frame()), classes = NULL,
             includeDefs = FALSE, inherited = !includeDefs,
             showEmpty, printTo = stdout(), fdef = getGeneric(f, where = where))
{
    if(missing(showEmpty))
	showEmpty <- !missing(f)
    if(isFALSE(printTo))
        con <- textConnection(NULL, "w")
    else
        con <- printTo
    ## must resolve showEmpty in line; using an equivalent default
    ## fails because R resets the "missing()" result for f later on (grumble)
    if(is.function(f)) {
        fdef <- f ## note that this causes missing(fdef) to be FALSE below
        if(missing(where))
            where <- environment(f)
        f <- deparse(substitute(f))
        if(length(f) > 1L) f <- paste(f, collapse = "; ")
    }
    if(!is(f, "character"))
        stop(gettextf("first argument should be the names of one of more generic functions (got object of class %s)",
                      dQuote(class(f))), domain = NA)
    if(length(f) ==  0L) { ## usually, the default character()
        f <- if(missing(where)) getGenerics() else getGenerics(where)
    }
    if(length(f) == 0L)
	cat(file = con, "no applicable functions\n")
    else if(length(f) > 1L) {
	for(ff in f) { ## recall for each
            ffdef <- getGeneric(ff, where = where)
            if(missing(where)) {
                if(isGeneric(ff))
		    Recall(ff, classes=classes,
			   includeDefs=includeDefs, inherited=inherited,
			   showEmpty=showEmpty, printTo=con, fdef = ffdef)
            }
            else if(isGeneric(ff, where)) {
                Recall(ff, where=where, classes=classes,
                       includeDefs=includeDefs, inherited=inherited,
                       showEmpty=showEmpty, printTo=con, fdef = ffdef)
            }
	}
    }
    else { ## f of length 1 --- the "workhorse" :
        out <- paste0("\nFunction \"", f, "\":\n")
        if(!is(fdef, "genericFunction"))
            cat(file = con, out, "<not an S4 generic function>\n")
        else
            ## maybe no output for showEmpty=FALSE
            .showMethodsTable(fdef, includeDefs, inherited,
                              classes = classes, showEmpty = showEmpty,
                              printTo = con)
    }
    if(isFALSE(printTo)) {
        txtOut <- textConnectionValue(con)
        close(con)
        txtOut
    }
    else
        invisible(printTo)
}

.methods_info <-
    ## (not exported) simplify construction of standard data.frame
    ## return value from .S4methodsFor*
    function(generic=character(), signature=character(),
             visible=rep(TRUE, length(signature)), from=character())
{
    if (length(signature))
        signature <- paste0(generic, ",", signature, "-method")
    keep <- !duplicated(signature)
    data.frame(visible=visible[keep], from=from[keep],
               generic=generic[keep], isS4=rep(TRUE, sum(keep)),
               row.names=signature[keep], stringsAsFactors=FALSE)
}

.S4methodsForClass <-
    ## (not exported) discover methods for specific class;
    ## generic.function ignored
    function(generic.function, class)
{
    def <- tryCatch(getClass(class), error=function(...) NULL)
    if (is.null(def))
        return(.methods_info())

    classes <- c(class, names(getClass(class)@contains))
    generics <- as.vector(getGenerics(where=search()))
    nms <- setNames(generics, generics)

    packages <- lapply(nms, function(generic) {
	table <- environment(getGeneric(generic))[[".MTable"]]
	lapply(table, function(m) environmentName(environment(m)))
    })
    methods <- lapply(nms, function(generic) {
	table <- environment(getGeneric(generic))[[".MTable"]]
	lapply(table, function(m) {
            if (is(m, "MethodDefinition") && any(m@defined %in% classes))
                setNames(as.vector(m@defined), names(m@defined))
            ## else NULL
        })
    })

    geom <- lapply(methods, function(method) {
        !vapply(method, is.null, logical(1))
    })
    filter <- function(elt, geom) elt[geom]
    packages <- Map(filter, packages, geom)
    methods  <- Map(filter, methods,  geom)
    non0 <- lengths(methods) != 0L
    packages <- packages[non0]
    methods  <-  methods[non0]

    ## only derived methods
    geom <- lapply(methods, function(method, classes) {
        sig <- simplify2array(method)
        if (!is.matrix(sig))
            sig <- matrix(sig, ncol=length(method))
        idx <- apply(sig, 2, match, classes, 0)
        if (!is.matrix(idx))
            idx <- matrix(idx, ncol=ncol(sig))
        keep <- colSums(idx != 0) != 0
        sidx <- idx[,keep, drop=FALSE]

        ## 'nearest' method
        shift <- c(0, cumprod(pmax(1, apply(sidx, 1, max)))[-nrow(sidx)])
        score <- colSums(sidx + shift)
        sig0 <- sig <- sig[,keep, drop=FALSE]
        sig0[sidx != 0] <- "*"
        sig0 <- apply(sig0, 2, paste, collapse="#")
        split(score, sig0) <-
            lapply(split(score, sig0), function(elt) elt == min(elt))
        score == 1
    }, classes)

    packages <- Map(filter, packages, geom)
    methods  <- Map(filter, methods,  geom)

    generic <- rep(names(methods), lengths(methods))
    signature <- unlist(lapply(methods, function(method) {
        vapply(method, paste0, character(1L), collapse=",")
    }), use.names=FALSE)
    package <- unlist(packages, use.names=FALSE)

    .methods_info(generic=generic, signature=signature, from=package)
}

.S4methodsForGeneric <-
    ## (not exported) discover methods for specific generic; class
    ## ignored.
    function(generic.function, class)
{
    if (is.null(getGeneric(generic.function)))
        return(.methods_info())

    mtable <- ".MTable"
    generic <- generic.function
    table <- get(mtable, environment(getGeneric(generic)))
    packages <- sapply(names(table), function(nm, table) {
        environmentName(environment(table[[nm]]))
    }, table)

    methods <- names(table)
    signatures <- lapply(methods, function(method, classes) {
        m <- table[[method]]
        if (is(m, "MethodDefinition"))
            setNames(as.vector(m@defined), names(m@defined))
        else
            NULL
    })

    geom <- vapply(signatures, Negate(is.null), logical(1))
    packages <- packages[geom]
    methods <- methods[geom]
    signatures <- sapply(signatures[geom], function(elt) {
        paste0(as.vector(elt), collapse=",")
    })

    .methods_info(generic=rep(generic.function, length(packages)), from=packages,
                  signature=signatures)
}

.S4methods <-
    ## discover methods by generic or class, primarily for interactive
    ## display via utils::methods()
    function(generic.function, class)
{
    info <- if (!missing(generic.function))
        .S4methodsForGeneric(generic.function, class)
    else if (!missing(class))
        .S4methodsForClass(generic.function, class)
    else
        stop("must supply 'generic.function' or 'class'")
    structure(rownames(info), info=info, byclass=missing(generic.function),
              class="MethodsFunction")
}

removeMethods <-
  ## removes all the methods defined for this generic function.  Returns `TRUE' if
  ## `f' was a generic function, `FALSE' (silently) otherwise.
  ##
  ## If there is a default method, the function will be re-assigned as
  ## a simple function with this definition; otherwise, it will be removed.  The
  ## assignment or removal can be controlled by optional argument `where', which
  ## defaults to the first element of the search list having a function called `f'.
  function(f, where = topenv(parent.frame()), all = missing(where))
{
    ## NOTE:  The following is more delicate than one would like, all because of
    ## methods for primitive functions.  For those, no actual generic function exists,
    ## but isGeneric(f) is TRUE if there are methods.  We have to get the default from
    ## the methods object BEFORE calling removeMethodsObject, in case there are no more
    ## methods left afterwards. AND we can't necessarily use the same default "where"
    ## location for methods object and generic, for the case of primitive functions.
    ## And missing(where) only works in R BEFORE the default is calculated.  Hence
    ## the peculiar order of computations and the explicit use of missing(where).
    fdef <- getGeneric(f, where = where)
    if(!is(fdef, "genericFunction")) {
        warning(gettextf("%s is not an S4 generic function in %s; methods not removed",
                         sQuote(f),
                         sQuote(getPackageName(where))),
                domain = NA)
        return(FALSE)
    }

    methods <- getMethodsForDispatch(fdef)
    default <- getMethod(fdef, "ANY", optional = TRUE)
    fMetaName <- .TableMetaName(fdef@generic, fdef@package)
    oldMetaName <- methodsPackageMetaName("M",fdef@generic, fdef@package)
    allWhere <- .findAll(fMetaName, where)
    if(!all)
        allWhere <- allWhere[1L]
    value <- rep(TRUE, length(allWhere))
    ## cacheGenericsMetaData is called to clear primitive methods if there
    ## are none for this generic on other databases.
    cacheGenericsMetaData(f, fdef, FALSE, where)
    .uncacheGeneric(f, fdef) # in case it gets removed or re-assigned
    doGeneric <- TRUE # modify the function
    for(i in seq_along(allWhere)) {
        db <- as.environment(allWhere[[i]])
        if(environmentIsLocked(db)) {
                warning(gettextf("cannot remove methods for %s in locked environment/package %s",
                                 sQuote(f), sQuote(getPackageName(db))),
                        domain = NA)
                value[[i]] <- FALSE
                next
            }
            if(exists(fMetaName, db, inherits = FALSE)) {
                ## delete these methods from the generic
                theseMethods <- get(fMetaName, db)
                .mergeMethodsTable(fdef, methods, theseMethods, FALSE)
                rm(list = fMetaName, pos = db)
                if(exists(oldMetaName, db, inherits = FALSE))
                  rm(list = oldMetaName, pos = db)
            }
    }
    all <- all && base::all(value) # leave methods on any locked packages
    # now find and reset the generic function
    for(i in seq_along(allWhere)) {
        db <- as.environment(allWhere[[i]])
        if(doGeneric && isGeneric(f, db)) {
            ## restore the original function if one was used as default
            if(all && is(default, "derivedDefaultMethod")) {
                default <- as(default, "function") # strict, removes slots
                rm(list=f, pos = db)
                if(!existsFunction(f, FALSE, db)) {
                    message(gettextf("Restoring default function definition of %s",
                                     sQuote(f)),
                            domain = NA)
                    assign(f, default, db)
                }
                ## else the generic is removed, nongeneric will be found elsewhere
            }
            ## else, leave the generic in place, with methods removed
            ## and inherited methods reset
            else {
                resetGeneric(f, fdef, where = db, deflt = default)
            }
            doGeneric <- FALSE
        }
    }
    any(value)
}


resetGeneric <- function(f, fdef = getGeneric(f, where = where),
			 mlist = getMethodsForDispatch(fdef),
			 where = topenv(parent.frame()),
			 deflt = finalDefaultMethod(mlist))
{
    if(!is(fdef, "genericFunction")) {
            stop(gettextf("error in updating S4 generic function %s; the function definition is not an S4 generic function (class %s)", sQuote(f), dQuote(class(fdef))),
                 domain = NA)
        }
    ## reset inherited methods
    .updateMethodsInTable(fdef, attach = "reset")
    f
}

setReplaceMethod <-
  function(f, ..., where = topenv(parent.frame()))
  setMethod(paste0(f, "<-"), ..., where = where)

setGroupGeneric <-
    ## create a group generic function for this name.
    function(name, def = NULL, group = list(), valueClass = character(),
             knownMembers = list(), package = getPackageName(where), where = topenv(parent.frame()))
{
    if(is.null(def)) {
        def <- getFunction(name, where = where)
        if(isGroup(name, fdef = def)) {
            if(nargs() == 1) {
                message(gettextf("Function %s is already a group generic; no change",
                                 sQuote(name)),
                        domain = NA)
                return(name)
            }
        }
    }
    ## By definition, the body must generate an error.
    body(def, envir = environment(def)) <- substitute(
              stop(MSG, domain = NA),
              list(MSG =
                   gettextf("Function %s is a group generic; do not call it directly",
                            sQuote(name))))
    if(is.character(knownMembers))
        knownMembers <- as.list(knownMembers) # ? or try to find them?
    setGeneric(name, def, group = group, valueClass = valueClass,
               package = package, useAsDefault = FALSE,
               genericFunction =
                 new("groupGenericFunction", def, groupMembers = knownMembers),
               where = where)
    .MakeImplicitGroupMembers(name, knownMembers, where)
    name
}

isGroup <-
  function(f, where = topenv(parent.frame()), fdef = getGeneric(f, where = where))
  {
    is(fdef, "groupGenericFunction")
  }

getGenericFromCall <- function(call, methodEnv) {
    generic <- methodEnv$.Generic
    if(is.null(generic)) {
        fdef <- if (is.name(call[[1L]]))
            getGeneric(as.character(call[[1L]]), mustFind=TRUE, where=methodEnv)
        else call[[1L]]
        generic <- environment(fdef)$.Generic
    }
    generic
}

fromNextMethod <- function(call) {
  identical(call[[1L]], quote(.nextMethod))
}

callGeneric <- function(...) {
    call <- sys.call(sys.parent(1L))
    .local <- identical(call[[1L]], quote(.local))
    methodCtxInd <- 1L + if (.local) 1L else 0L
    callerCtxInd <- methodCtxInd + 1L
    methodCall <- sys.call(sys.parent(methodCtxInd))
    if (fromNextMethod(methodCall)) {
        methodCtxInd <- methodCtxInd + 1L
    }
    methodFrame <- parent.frame(methodCtxInd)
    genericName <- getGenericFromCall(methodCall, methodFrame)
    if (is.null(genericName)) {
        stop("callGeneric() must be called from within a method body")
    }
    if (nargs() == 0L) {
        callerFrame <- sys.frame(sys.parent(callerCtxInd))
        methodDef <- sys.function(sys.parent(1L))
        call <- match.call(methodDef,
                           methodCall,
                           expand.dots=FALSE,
                           envir=callerFrame)
        call[-1L] <- lapply(names(call[-1L]), as.name)
    } else {
        call <- sys.call()
    }
    call[[1L]] <- as.name(genericName)
    eval(call, parent.frame())
}

## This uses 'where' to record the methods namespace: default may not be that
initMethodDispatch <- function(where = topenv(parent.frame()))
    .Call(C_R_initMethodDispatch, as.environment(where))# C-level initialization

### dummy version for booting
isSealedMethod <- function(f, signature, fdef = getGeneric(f, FALSE, where = where),
			   where = topenv(parent.frame())) FALSE

### real version
.isSealedMethod <- function(f, signature, fdef = getGeneric(f, FALSE, where = where),
			   where = topenv(parent.frame()))
{
    ## look for the generic to see if it is a primitive
    fGen <- getFunction(f, TRUE, FALSE, where = where)
    if(!is.primitive(fGen)) {
        mdef <- getMethod(f, signature, optional = TRUE, where = where, fdef = fGen)
        return(is(mdef, "SealedMethodDefinition"))
    }
    ## else, a primitive
    if(is(fdef, "genericFunction"))
        signature <- matchSignature(signature, fdef)
    if(length(signature) == 0L)
        TRUE # default method for primitive
    else if(f %in% .subsetFuns)
        ## primitive dispatch requires some argument to be an S4 object.
        ## This does not quite guarantee an S4 object; e.g., a class union might have only basic types in it.
        !any(is.na(match(signature, .BasicClasses)))
    else {
        sealed <- !is.na(match(signature[[1L]], .BasicClasses))
        if(sealed &&
           (!is.na(match("Ops", c(f, getGroup(f, TRUE))))
            || !is.na(match(f, c("%*%", "crossprod")))))
            ## Ops methods are only sealed if both args are basic classes
            sealed <- sealed && (length(signature) > 1L) &&
                      !is.na(match(signature[[2L]], .BasicClasses))
        sealed
    }
}

.subsetFuns <- c("[", "[[","[<-","[[<-")

.lockedForMethods <- function(fdef, env) {
    ## the env argument is NULL if setMethod is only going to assign into the
    ## table of the generic function, and not to assign methods list object
    if(is.null(env) || !environmentIsLocked(env))
        return(FALSE) #? can binding be locked and envir. not?
    if(!is(fdef, "genericFunction"))
      return(TRUE)
    name <- fdef@generic
    package <- fdef@package
    objs <- c(name, .TableMetaName(name, package))
    for(obj in objs) {
        hasIt <- exists(obj, env, inherits = FALSE)
        ## the method object may be bound, or a new one may be needed
        ## in which case the env. better not be locked
        if((!hasIt || bindingIsLocked(obj, env)))
            return(TRUE)
    }
    FALSE
}

implicitGeneric <- function(...) NULL

## real version, installed after methods package initialized

.implicitGeneric <- function(name, where = topenv(parent.frame()),
                             generic = getGeneric(name, where = where))
### Add the named function to the table of implicit generics in environment where.
###
### If there is a generic function of this name, it is saved to the
### table.  This is the reccomended approach and is required if you
### want the saved generic to include any non-default methods.
###
  {
      if(!nzchar(name))
        stop(gettextf('expected a non-empty character string for argument name'), domain = NA)
      if(!missing(generic) && is(generic, "genericFunction") && !.identC(name, generic@generic))
        stop(gettextf('generic function supplied was not created for %s',
                      sQuote(name)),
             domain = NA)
      createGeneric <- (missing(generic) || !is(generic, "genericFunction")) && !isGeneric(name, where)
      if(createGeneric) {
          fdefault <- getFunction(name, where = where, mustFind = FALSE)
          if(is.null(fdefault))
            return(NULL)  # no implicit generic
          env <- environment(fdefault) # the environment for an implicit generic table
          fdefault <- .derivedDefaultMethod(fdefault)
          if(isBaseFun(fdefault)) {
              value <- genericForBasic(name)
              if (is.function(value)) {
                  if(!missing(generic) && !identical(value, generic))
                      stop(gettextf("%s is a primitive function; its generic form cannot be redefined",
                                    sQuote(name)),
                           domain = NA)
                  generic <- value
                  fdefault <- generic@default
              }
              package <- "base"
          }
          else
              package <- getPackageName(env)
          ## look for a group
          group <-
              .getImplicitGroup(name,
                                if(identical(package,"base"))
                                .methodsNamespace else environment(fdefault))
          if(missing(generic)) {
            generic <- .getImplicitGeneric(name, env, package)
            if(is.null(generic))  { # make a new one
                generic <- makeGeneric(name, fdefault = fdefault, package = package,
                                       group = group)
                .cacheImplicitGeneric(name, generic)
            }
          }
          else {
            generic <- makeGeneric(name, generic, fdefault, package = package,
                                   group = group)
            .cacheImplicitGeneric(name, generic)
        }
      }
      generic
  }

setGenericImplicit <- function(name, where = topenv(parent.frame()), restore = TRUE) {
    if(!isGeneric(name, where)) {
        warning(gettextf("%s is not currently a generic:  define it first to create a non-default implicit form",
                         sQuote(name)),
                domain = NA)
        return(FALSE)
    }
    generic <- getGeneric(name, where = where)
    if(restore)
        removeMethods(name, where, TRUE)
    else
        removeGeneric(name, where)
    .saveToImplicitGenerics(name, generic, where)
}

prohibitGeneric <- function(name, where = topenv(parent.frame()))
### store a definition in the implicit generic table that explicitly prohibits
### a function from being made generic
  {
      .saveToImplicitGenerics(name, FALSE, where)
  }

registerImplicitGenerics <- function(what = .ImplicitGenericsTable(where),
                                     where = topenv(parent.frame()))
{
    if(!is.environment(what))
        stop(gettextf("must provide an environment table; got class %s",
                      dQuote(class(what))), domain = NA)
    objs <- as.list(what, all.names = TRUE)
    mapply(.cacheImplicitGeneric, names(objs), objs)
    NULL
}


### the metadata name for the implicit generic table
.ImplicitGenericsMetaName <- ".__IG__table" # methodsPackageMetaName("IG", "table")

.ImplicitGenericsTable <- function(where)
  {
### internal utility to add a function to the implicit generic table
      if(!exists(.ImplicitGenericsMetaName, where, inherits = FALSE))
        assign(.ImplicitGenericsMetaName, new.env(TRUE), where)
      get(.ImplicitGenericsMetaName, where)
  }

.saveToImplicitGenerics <- function(name, def, where)
  .cacheGenericTable(name, def, .ImplicitGenericsTable(where))

.getImplicitGeneric <- function(name, where, pkg = "")
{
    value <- .getImplicitGenericFromCache(name, where, pkg)
    if(is.null(value) && !is.null(tbl <- where[[.ImplicitGenericsMetaName]]))
       .getGenericFromCacheTable(name, where, pkg, tbl)
    else
        value
}

## only called from setGeneric, f1 = supplied, f2 = implicit
.identicalGeneric <- function(f1, f2, allow.extra.dots = FALSE)
{
    gpString <- function(gp) {
	if(length(gp))
	    paste(as.character(gp), collapse = ", ")
	else
	    "<none>"
    }
    if(isFALSE(f2))
	return(gettext("original function is prohibited as a generic function"))
    if(!(is.function(f2) && is.function(f1)))
	return(gettext("not both functions!"))
    ## environments will be different
    if(!identical(class(f1), class(f2)))
	return(sprintf("classes: %s, %s",
                       .dQ(class(f1)), .dQ(class(f2))))
    if(!isS4(f1)) return(gettextf("argument %s is not S4",
                                  deparse1(substitute(f1))))
    if(!isS4(f2)) return(gettextf("argument %s is not S4",
                                  deparse1(substitute(f2))))
    f1d <- f1@.Data
    f2d <- f2@.Data
    ## xtra... <- FALSE
    if(!identical(formals(f1d), formals(f2d))) {
	a1 <- names(formals(f1d)); a2 <- names(formals(f2d))
	if(identical(a1, a2))
	    return(gettext("formal arguments differ (in default values?)"))
	else if(identical(c(a1, "..."), a2) && allow.extra.dots)
            ## silently accept an extra "..."
            { } ## xtra... <- TRUE
	    ## and continue
	else
	    return(gettextf("formal arguments differ: (%s), (%s)",
			    paste(a1, collapse = ", "),
			    paste(a2, collapse = ", ")))
    }
    if(!identical(f1@valueClass, f2@valueClass))
	return(gettextf("value classes differ: %s, %s",
                        .dQ(gpString(f1@valueClass)),
                        .dQ(gpString(f2@valueClass))))
    if(!identical(body(utils::removeSource(f1d)),
                  body(utils::removeSource(f2d))))
	return("function body differs")
    if(!identical(f1@signature, f2@signature))
	return(gettextf("signatures differ:  (%s), (%s)",
                        paste(f1@signature, collapse = ", "),
                        paste(f2@signature, collapse = ", ")))
    if(!identical(f1@package, f2@package))
	return(gettextf("package slots  differ: %s, %s",
                        .dQ(gpString(f1@package)),
                        .dQ(gpString(f2@package))))
    if(!identical(f1@group, f2@group)) {
	return(gettextf("groups differ: %s, %s",
                        .dQ(gpString(f1@group)),
                        .dQ(gpString(f2@group))))
    }
    if(!identical(as.character(f1@generic), as.character(f2@generic)))
	return(gettextf("generic names differ: %s, %s",
                        .dQ(f1@generic), .dQ(f2@generic)))
    TRUE
}

.ImplicitGroupMetaName <- ".__IGM__table"
.MakeImplicitGroupMembers <- function(group, members, where) {
    if(!exists(.ImplicitGroupMetaName, where, inherits = FALSE))
        assign(.ImplicitGroupMetaName, new.env(TRUE), where)
    tbl <- get(.ImplicitGroupMetaName, where)
    for(what in members)
        assign(what, as.list(group), envir = tbl)
    NULL
}

.getImplicitGroup <- function(name, where) {
    if(!is.null(tbl <- where[[.ImplicitGroupMetaName]])) {
	if(!is.null(r <- tbl[[name]]))
	    return(r)
    }
    list()
}

findMethods <- function(f, where, classes = character(), inherited = FALSE, package = "") {
    if(is(f, "genericFunction")) {
        fdef <- f
        f <- fdef@generic
    }
    else if(.isSingleString(f)) {
        if(missing(where))
            fdef <- getGeneric(f, package = package)
        else { # the generic may not be in the where= environment
            ##  but we prefer that version if it is
            fdef <- getGeneric(f, where = where, package = package)
            if(is.null(fdef))
                fdef <- getGeneric(f, package = package)
        }
    }
    else if(!is.function(f))
        stop(gettextf("argument %s must be a generic function or a single character string; got an object of class %s",
                      sQuote("f"), dQuote(class(f))),
             domain = NA)
    else {
        fdef <- f
        f <- deparse1(substitute(f))
    }
    if(!is(fdef, "genericFunction")) {
        warning(gettextf("non-generic function '%s' given to findMethods()", f),
                domain = NA)
        return(list())
    }
    object <- new("listOfMethods", arguments = fdef@signature,
                  generic = fdef) # empty list of methods
    if(missing(where))
      table <- get(if(inherited) ".AllMTable" else ".MTable", envir = environment(fdef))
    else {
        if(!isFALSE(inherited))
          stop(gettextf("only FALSE is meaningful for 'inherited', when 'where' is supplied (got %s)", inherited), domain = NA)
        where <- as.environment(where)
        what <- .TableMetaName(f, fdef@package)
        if(is.null(table <- where[[what]]))
          return(object)
    }
    objNames <- sort(names(table))
    if(length(classes)) {
        classesPattern <- paste0("#", classes, "#", collapse = "|")
        which <- grep(classesPattern, paste0("#",objNames,"#"))
        objNames <- objNames[which]
    }
    object@.Data <- mget(objNames, table)
    object@names <- objNames
    object@signatures <- strsplit(objNames, "#", fixed = TRUE)
    object
}

findMethodSignatures <- function(..., target = TRUE, methods = findMethods(...))
{
    what <- methods@arguments
    if(target)
      sigs <- methods@signatures
    else {
        anySig <- rep("ANY", length(what))
        ## something of a kludge for the case of some primitive
        ## default methods to get a vector of "ANY" of right length
        for(m in methods)
          if(!is.primitive(m)) {
              length(anySig) <- length(m@defined)
              break
          }
        sigs <- lapply(methods, function(x)
                       if(is.primitive(x)) anySig else as.character(x@defined))
    }
    lens <- unique(vapply(sigs, length, 1, USE.NAMES=FALSE))
    if(length(lens) == 0)
        return(matrix(character(), 0, length(methods@arguments)))
    if(length(lens) > 1L) {
        lens <- max(lens)
        anys <- rep("ANY", lens)
        sigs <- lapply(sigs, function(x) {
            if(length(x) < lens) {
              anys[seq_along(x)] <- x
              anys
          } else x
        })
    }
    length(what) <- lens # if not all possible arguments used
    t(matrix(unlist(sigs), nrow = lens, dimnames = list(what, NULL)))
}

hasMethods <- function(f, where, package = "")
{
    fdef <- NULL
    nowhere <- missing(where) # because R resets this if where is assigned
    if(is(f, "genericFunction")) {
        fdef <- f
        f <- fdef@generic
        if(missing(package))
            package <- fdef@package
    }
    else if(!.isSingleString(f))
        stop(gettextf("argument 'f' must be a generic function or %s",
                      .notSingleString(f)), domain = NA)
    else if(missing(package)) {
        package <- packageSlot(f) # maybe a string with package slot
	if(is.null(package)) {
            if(missing(where))
                fdef <- getGeneric(f)
            else { # the generic may not be in this package, but prefer it if so
                fdef <- getGeneric(f, where = where)
                if(is.null(fdef))
                    fdef <- getGeneric(f)
            }
            if(is(fdef, "genericFunction"))
                package <- fdef@package
	    else
		stop(gettextf("'%s' is not a known generic function {and 'package' not specified}",
			      f),
		     domain = NA)
	}
    }
    what <- .TableMetaName(f, package)
    testEv <- function(ev)
      exists(what, envir = ev, inherits = FALSE) &&
        length(names(get(what, envir = ev))) > 0L
    if(nowhere) {
        for(i in seq_along(search())) {
            if(testEv(as.environment(i)))
              return(TRUE)
        }
        return(FALSE)
    }
    else
      testEv(as.environment(where))
}
## returns TRUE if the argument is a non-empty character vector of length 1
## otherwise, returns a diagnostic character string reporting the non-conformance
.isSingleName <- function(x) {
    if(!is.character(x))
      return(paste0('required to be a character vector, got an object of class "', class(x)[[1L]], '"'))
    if(length(x) != 1)
      return(paste0("required to be a character vector of length 1, got length ",length(x)))
    if(is.na(x) || !nzchar(x))
      return(paste0('required a non-empty string, got "',x, '"'))
    TRUE
}
